Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue28/subclass/AutoMemo.pas

Pascal/Delphi Source File | 1997-09-07 | 7.6 KB | 263 lines

unit AutoMemo;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  eAutoMemoError = class(exception);

  tSynMemoScrollEnum = (smAutoScroll, smVertical, smHoriz, smBoth, smNoScroll);

  TAutoMemo = class(TCustomMemo)
  private
    fScrolling : tSynMemoScrollEnum;
    oldwinproc : pointer;
    newWinProc : pointer;
    fSubClassDone : boolean;
    procedure SubClassParentFunc(var Msg : tmessage);
    function getScrollOption : tsynMemoScrollEnum;
    procedure setScrollOption(aOption : tSynMemoScrollEnum);
    function getLinesShowing : integer;
    procedure setLinesShowing(numLines : integer);
    function getLineHeight : integer;
    function getLineWidth(aline: integer): integer;
    procedure WMERASEBKGND(var Message: TMessage); message WM_ERASEBKGND;
  protected
    procedure CheckScrolling; virtual;
    procedure TurnOnSubClassing;
    Procedure TurnOffSubClassing;
    function LongestLine : integer;
  public
    constructor create(aOwner : tcomponent); override;
    destructor destroy; override;
    property LineHeight : integer read GetLineHeight;
    property LineWidth[aline : integer] : integer read GetLineWidth;
  published
    property ScrollOption : tsynMemoScrollEnum read getSCrollOption write setScrollOption default smAutoScroll;
    property Align;
    property Alignment;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property HideSelection;
    property Lines;
    property MaxLength;
    property OEMConvert;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
//    property ScrollBars;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property WantReturns;
    property WantTabs;
    property WordWrap;
    property OnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

function maxOf(const first, second : integer):integer;
begin
  if first > second
    then result := first
    else result := second;
end;


constructor tAutoMemo.create(aOwner : tcomponent);
begin
  inherited create(aOwner);
  fScrolling := smAutoScroll;
  fsubClassDone := false;
end;

Destructor tAutoMemo.destroy;
begin
  FreeObjectInstance(NewWinProc);
  inherited destroy;
end;

procedure tAutoMemo.WMERASEBKGND(var Message: TMessage);
begin
  inherited;
  if not fSubclassDone
    then TurnOnSubclassing;
end;

Procedure tAutoMemo.TurnOnSubclassing;
begin
  if HandleAllocated and (not fsubclassDone)
       then begin
         if NewWinProc <> nil
           then FreeObjectInstance(newWinProc);
         NewWinProc := MakeObjectInstance(SubClassParentFunc);
         OldWinProc := Pointer(setWindowLong(parent.handle, GWL_WNDPROC, longint(NewWinProc)));
         if OldWinProc = nil
           then raise eAutoMemoError.create('subclass failed');
         fSubClassDone := true;
         end;
end;

Procedure tAutoMemo.TurnOffSubclassing;
begin
  SetWindowLong(parent.handle, GWL_WNDPROC, longint(OldWinProc));
  fSubclassDone := false;
end;

function tAutoMemo.getScrollOption : tsynMemoScrollEnum;
begin result := fScrolling end;

procedure tAutoMemo.setScrollOption(aOption : tSynMemoScrollEnum);
begin
  fSCrolling := aOption;
  CheckScrolling;
end;

Procedure tAutoMemo.CheckScrolling;
var tmpScroll : tScrollStyle;

  function Translate(customScrollEnum : tSynMemoScrollEnum ): tscrollstyle;
  begin
    case CustomScrollEnum of
      smAutoScroll : result := ssNone;
      smVertical   : result := ssVertical;
      smHoriz      : result := ssHorizontal;
      smBoth       : result := ssBoth;
      smNoScroll   : result := ssNone;
      end;
    end;

begin
  tmpScroll := translate(fScrolling);
  if fScrolling = smAutoScroll
    then begin
      if not fSubClassDone
        then TurnOnSubClassing;
      if lines.count*lineheight > clientheight
           then tmpScroll := ssVertical
           else tmpScroll := ssNone;
       if WordWrap = false
         then if (longestline > clientwidth) and (getLinesShowing > 1)
             then begin
                if TmpScroll = ssVertical
                   then TmpScroll := ssBoth
                   else TmpScroll := ssHorizontal;
                end
             else begin
                if TmpScroll = ssBoth
                   then TmpScroll := ssVertical
                   else if lines.count*lineheight > clientheight
                     then TmpScroll := ssVertical
                     else TmpScroll := ssNone;
                end;
      end
    else TurnOffSubClassing;
  case fSCrolling of
    smAutoSCroll : if scrollbars <> TmpScroll then scrollbars := tmpScroll;
    smVertical : if scrollbars <> ssVertical then scrollbars := ssVertical;
    smHoriz : if scrollbars <> ssHorizontal then scrollbars := ssHorizontal;
    smBoth  : if scrollbars <> ssBoth then scrollbars := ssboth;
    smNoScroll : if scrollbars <> ssNone then scrollbars := ssnone;
    end;
end;

procedure tAutoMemo.SubClassParentFunc(var Msg : tmessage);
begin
  with msg do begin
    Result := CallWindowProc(OldWinProc, Parent.handle, Msg, wParam, lParam);
    if (msg = WM_COMMAND) and (lparam = handle)
      then if WParamHi = en_change then CheckSCrolling;
    if msg = WM_DESTROY
      then   SetWindowLong(parent.handle, GWL_WNDPROC, longint(OldWinProc));
    end;
end;


function tAutoMemo.getLineHeight : integer;
Var
  oldfont: HFont;  {the old font}
  dc: THandle;     {a dc handle}
  tm: TTextMetric; {text metric structure}
  textSize : tSize;
const junk : pchar = 'X';
begin
  result := (height - clientheight);
  dc := GetDC(handle); {Get the Dc for the memo}
  oldFont := SelectObject(dc, Font.handle); {now make sure we have the memo's font}
    {if I don't do the line above, then the text size is 2 pixels too big...}
  GetTextMetrics(dc, tm); {Get the text metric info}
  GetTextExtentPoint32(dc, junk, 1, textSize); {and get the height in this font}
  result := textsize.cy + 2*tm.tmExternalLeading;
  SelectObject(dc, oldfont); {Select the old font -- I'm not sure if or why we need this, but Lloyd's file said so...}
  ReleaseDC(handle, dc); {Release the Dc}
end;

function tAutoMemo.getLineWidth(aline: integer): integer;
var
  oldfont: HFont;  {the old font}
  dc: THandle;     {a dc handle}
  textSize : tSize;
begin
   dc := GetDC(handle);
  oldFont := SelectObject(dc, Font.handle); {Select the memo's font}
   GetTextExtentPoint32(dc, pchar(lines[aline]), length(lines[aline]), textSize);
   result := textsize.cx;
  SelectObject(dc, oldfont); {Select the old font}
  ReleaseDC(handle, dc); {Release the Dc}
end;


function tAutoMemo.LongestLine: integer;
var i : integer;
begin
  result := 0;
  for i := 0 to lines.count - 1 do
    result := maxof(result, LineWidth[i]);
end;

function tAutoMemo.getLinesShowing : integer;
begin
  result := (Height - (height - clientHeight+2)) div lineheight;
end;

procedure tAutoMemo.setLinesShowing(numLines : integer);
begin
  height := (maxof(numlines,0))*lineheight + (Height - ClientHeight+2);
end;


procedure Register;
begin
  RegisterComponents('Samples', [TAutoMemo]);
end;

end.